(define-module (basket cairo)
               #:use-module (cairo)
               #:use-module (srfi srfi-1)
               #:use-module (basket)
               #:use-module (basket vec))

(export
  render-cairo-png
  render-cairo-svg)

;; special version of for-each. only takes one list at a time, so it's not exported
(define (for-each-tail f x)
  (cond
    ((null? x))
    ((null? (cdr x)) (f (car x)))
    (else
      (f (car x))
      (for-each-tail f (cdr x)))))

(define (pair-func fn)
  "Takes a function that takes a context followed by an even number of arguments, and
  returns a function that takes context and a number of pairs."
  (lambda (ctx . x) (apply fn ctx
                           (apply append
                                  (map (lambda (p) (list (vec-x p) (vec-y p))) x)))))

(define (render-path ctx path)
  (cond ((thunk? path)
         (render-path ctx (path)))
        ((path? path)
         ((pair-func cairo-move-to) ctx (car path))
         (if (= (length path) 1)
             ((pair-func cairo-line-to) ctx (car path)))
         (for-each (curry (pair-func cairo-line-to) ctx) (cdr path)))
        ((cpath? path)
         (render-path ctx (cdr path))
         (cairo-close-path ctx))
        ((vec? path)
         ((pair-func cairo-move-to) ctx path)
         ((pair-func cairo-line-to) ctx path))
        ((list? path) (for-each (curry render-path ctx) path))))

(define (render-stroke ctx args)
  (for-each (curry render-path ctx) args)
  (cairo-stroke ctx))

(define (render-fill ctx args)
  (for-each (curry render-path ctx) args)
  (cairo-fill ctx))

(define (render-clear ctx args)
  (cairo-save ctx)
  (if (> (length args) 0)
      (set-color ctx (car args))
      (set-color ctx '(0 0 0)))
  (cairo-set-operator ctx 'clear)
  (render-fill ctx '((0 . 0) (1 . 0) (1 . 1) (0 . 1)))
  (cairo-paint ctx)
  (cairo-restore ctx))

(define (set-line-width ctx x)
  (cairo-set-line-width ctx (/ x 256)))

(define (color-hex color)
  (map
    (lambda (pos)
      (/ (string->number (substring color pos (+ pos 2)) 16) 255))
    (iota (/ (string-length color) 2) 0 2)))

(define (set-color ctx color)
  (cond
    ((string? color) (set-color ctx (color-hex color)))
    (else
      (apply
        (cond
          ((= (length color) 4) cairo-set-source-rgba)
          ((= (length color) 3) cairo-set-source-rgb))
        ctx color))))

(define param-funcs
  `((line-width . ,set-line-width)
    (line-join . ,cairo-set-line-join)
    (line-cap . ,cairo-set-line-cap)
    (antialias . ,cairo-set-antialias)
    (color . ,set-color)))

(define (render-set ctx args)
  (let ((params (if (symbol? (caar args)) (list (car args)) (car args))))
    (cairo-save ctx)
    (for-each
      (lambda (elem)
        (let ((f (assq (car elem) param-funcs)))
          (if f ((cdr f) ctx (cadr elem)))))
      params)
    (render-elem ctx (cadr args))
    (cairo-restore ctx)))

(define element-funcs
  `((stroke . ,render-stroke)
    (fill . ,render-fill)
    (clear . ,render-clear)
    (set . ,render-set)))

(define (render-elem ctx elem)
  (cond
    ((null? elem))
    ((thunk? elem) (render-elem ctx (elem)))
    ((list? (car elem)) (for-each-tail (curry render-elem ctx) elem))
    (else
      (let ((f (assq (car elem) element-funcs)))
        (if f ((cdr f) ctx (cdr elem)))))))

(define (init-context ctx width height)
  (cairo-translate
    ctx
    (/ (- (- (max width height) width)) 2)
    (/ (- (- (max width height) height)) 2))
  (cairo-scale ctx (max width height) (max width height))
  (cairo-set-source-rgb ctx 1 1 1)
  (cairo-paint ctx)
  (cairo-set-source-rgb ctx 0 0 0)
  (cairo-set-line-width ctx (/ 1 256))
  (cairo-set-line-join ctx 'round)
  (cairo-set-line-cap ctx 'round))

(define (render-cairo-png structure size filename)
  (let* ((width (if (number? size) size (vec-x size)))
         (height (if (number? size) size (vec-y size)))
         (surface (cairo-image-surface-create 'argb32 width height))
         (ctx (cairo-create surface)))
    (init-context ctx width height)
    (render-elem ctx structure)
    (cairo-surface-write-to-png (cairo-get-target ctx) filename)
    (cairo-surface-destroy surface)))

(define (render-cairo-svg structure size filename)
  (let* ((width (if (number? size) size (vec-x size)))
         (height (if (number? size) size (vec-y size)))
         (surface (cairo-svg-surface-create width height filename))
         (ctx (cairo-create surface)))
    (init-context ctx width height)
    (render-elem ctx structure)
    (cairo-surface-finish surface)))
